home *** CD-ROM | disk | FTP | other *** search
/ Workbench Design / WB Collection.iso / workbench werkzeuge / wbgames / getem / sources / getemsound.m < prev    next >
Text File  |  1996-04-07  |  7KB  |  288 lines
  1. Module GetemSound;
  2.  
  3. { © By M. Illenseer                                                          }
  4. { Überarbeitete Version 0.2 , 3.9.1991                                       }
  5. { Erstellt mit Kickpascal V2.0 , thanx to the Himpire !                      }
  6. { Spezielles Module für Getem ab V0.8                                        }
  7. { Compilieren und als GetemSound.o abspeichern, nicht vom Linker irritieren  }
  8. { lassen !                                                                   }
  9. { Ermöglicht Abspielung eines 8SVX-Sound-Files (Standard IFF Sound )         }
  10.  
  11. Uses ExecSupport, ExecIO;
  12. { Benötigt natuerlich auch Exec ! }
  13.  
  14. {$incl 'devices/audio.h' }
  15. {Braucht erst recht das AudioDevice... }
  16.  
  17. {Const Debug = 'Yes';} { Klammern löschen, wenn Debug erwuenscht }
  18.  
  19. { Folgende Funktionen und Proceduren sind hier deklariert:
  20.  
  21. Function  PlaySInit(Filename:string):Boolean;
  22.                     { Initialisiert den Sound, True wenn Device ok }
  23. Procedure Piep;     { Macht unserern schoenen 'Piep', ein 8SVX-File }
  24. Procedure EndPlay;  { Schliesst das Device wieder }
  25.  
  26. }
  27.  
  28. Const
  29.   CLOCK = 3579545; { Gut was !? }
  30.  
  31. Type
  32.   FileS = File of Byte; { Oder von mir aus auch File of Word ! }
  33.  
  34.   VHDRType = RECORD     { IFF Chunk }
  35.                OneShotHiSamples: Long;
  36.                RepeatHiSamples: Long;
  37.                SamplesPerHiCycle: Long;
  38.                SamplesPerSecond: Word;
  39.                Oktaven: Byte;
  40.                PackFlag: Byte;
  41.                Volume: Long
  42.              END;
  43.  
  44.   SamplePtr = ^SampleType;
  45.   SampleType = RECORD
  46.                  VHDR: VHDRType;
  47.                  Len: LongInt;
  48.                  Data: ARRAY[0..MaxLongInt] OF Short
  49.                END;
  50.  
  51.  
  52. Var F1                  : FileS;
  53.     Filename            : STRING;
  54.     MySample            : SamplePtr;
  55.     allocIOB, lockIOB   : ^IOAudio;
  56.     port                : ^MsgPort;
  57.     mydevice            : p_Device;
  58.     err                 : Long;
  59.  
  60.  
  61. Function LoadSample(VAR f: FileS): SamplePtr;
  62.   Type StrType = String[5];
  63.   Var sp: SamplePtr;
  64.       lw, err: LongInt;
  65.       s1: StrType;
  66.       HeadFlag, BodyFlag: Boolean;
  67.       VHDR: VHDRType;
  68.  
  69.   Function ReadStr4: StrType;  { Kommt auf das File an, manche Files haben Long-Words}
  70.     Var s: Array[1..5] OF Byte;
  71.         s2: String[5];
  72.     Begin
  73.       Read(f, s[1], s[2], s[3], s[4] );
  74.       s[5] := 0;
  75.       s2 := Str(^s);
  76.       ReadStr4 := S2;
  77.     End;
  78.  
  79.   Function ReadLong: LongInt;
  80.     Var b1, b2, b3, b4: Byte;
  81.     Begin
  82.       Read(f, b1, b2, b3, b4 );
  83.       ReadLong := Long( Long(b1 shl 8 + b2) shl 8 + b3) shl 8 + b4
  84.     End;
  85.  
  86.   Procedure Overread(Anz: LongInt);
  87.     Var b: Byte;
  88.     Begin
  89.       While Anz>0 DO
  90.         Begin
  91.           Read(f, b);
  92.           Dec(Anz)
  93.         End
  94.     End;
  95.  
  96.   Procedure ReadTo(Point: Ptr; Anz: Long );
  97.     Var p2: ^Array[1..MaxLongInt] Of Byte;
  98.         i: LongInt;
  99.     Begin
  100.       p2 := Point;
  101.       For i:=1 to Anz Do Read(f, p2^[i]);
  102.       { Blockread(f, p2^, Anz); }
  103.     End;
  104.  
  105.  
  106.   Begin    { LoadSample }
  107.     s1 := ReadStr4;
  108.     If s1 <> 'FORM' Then
  109.       Begin
  110. {$if def debug}
  111.         Writeln('Kein IFF-Format!');  { So ein Pech :-) }
  112. {$endif}
  113.         LoadSample := Nil;
  114.         Exit
  115.       End;
  116.     lw := ReadLong;
  117.     s1 := ReadStr4;
  118.     IF s1 <> '8SVX' THEN       { Magic-Number eines IFF-SoundFiles }
  119.       Begin
  120. {$if def Debug}
  121.         Writeln('Kein 8SVX-File!');
  122. {$endif}
  123.         LoadSample := Nil;
  124.         Exit
  125.       End;
  126.  
  127.     sp := Nil;
  128.     HeadFlag := false;
  129.     BodyFlag := false;
  130.  
  131.     While not (HeadFlag and BodyFlag) Do
  132.       Begin
  133.         s1 := ReadStr4;
  134.         lw := ReadLong;
  135.         IF s1='VHDR' THEN
  136.           Begin
  137.             ReadTo(^VHDR, SizeOf(VHDRType));
  138.             Overread(lw-SizeOf(VHDRType));
  139.             HeadFlag := true
  140.           End
  141.         Else
  142.         If s1='BODY' Then
  143.           Begin
  144.             If not HeadFlag Then
  145.               Begin
  146. {$if def debug}
  147.                 Writeln('Fehler in Dateiformat!');
  148. {$endif}
  149.                 LoadSample := Nil;
  150.                 Exit
  151.               End;
  152.             sp := Ptr (Alloc_Mem (lw+4+SizeOf(VHDRType), 2));
  153.             sp^.Len := lw+4+SizeOf(VHDRType);
  154.             sp^.VHDR := VHDR;
  155.             BlockRead(f, sp^.Data, lw);
  156.             BodyFlag := true
  157.           End
  158.         Else
  159.           OverRead(lw);
  160.  
  161.       End;
  162.  
  163.     LoadSample := sp
  164.   End;
  165.  
  166.  
  167.  
  168. Procedure InitAudio;
  169.   { Device öffnen, Ports einrichten, Kanäle reservieren usw. }
  170.   Var alloctable : Array[1..4] Of Byte;
  171.   Begin
  172.     port := CreatePort ('Getem Sound Port', 0);
  173.     If port=Nil Then Halt(0);
  174.  
  175.     allocIOB := CreateExtIO (port, SizeOf (IOAudio));
  176.     If allocIOB=Nil Then Halt(0);
  177.  
  178.     lockIOB := CreateExtIO (port, SizeOf (IOAudio));
  179.     If lockIOB=Nil Then Halt(0);
  180.  
  181.     Open_Device(AUDIONAME, 0, AllocIOB, 0);
  182.  
  183.     mydevice := allocIOB^.ioa_Request.io_Device;
  184.     lockIOB^.ioa_Request.io_Device := mydevice;
  185.  
  186.     AllocTable[1] := %0001;
  187.     AllocTable[2] := %0010;
  188.     AllocTable[3] := %0100;
  189.     AllocTable[4] := %1000;
  190.  
  191.     With allocIOB^, ioa_Request, io_Message Do
  192.       Begin
  193.         io_Flags := ADIOF_NOWAIT;
  194.         ioa_Data := ^AllocTable;
  195.         ioa_Length := 4;
  196.         io_Command := ADCMD_ALLOCATE;
  197.         BeginIO(allocIOB);
  198.       End;
  199.     err := WaitIO(allocIOB);
  200.     If err <> 0 Then
  201.       Error('Allocation failed');
  202.  
  203.     With lockIOB^, ioa_Request Do
  204.       Begin
  205.         io_Unit := allocIOB^.ioa_Request.io_Unit;
  206.         io_Command := ADCMD_LOCK;
  207.         ioa_AllocKey := allocIOB^.ioa_AllocKey;
  208.       End;
  209.     SendIO(lockIOB);
  210.     If CheckIO(lockIOB) <> 0 Then
  211.       Error('Channel stolen.');
  212.   End;
  213.  
  214.  
  215.  
  216. Procedure PlaySample(s: SamplePtr);
  217.   Var Laenge,Rate: Long;
  218.   Begin
  219.     With s^.VHDR Do
  220.       Begin
  221.         Laenge := OneShotHiSamples+RepeatHiSamples;
  222.         Rate := (CLOCK div SamplesPerSecond) div 2;
  223.       End;
  224.  
  225.     With lockIOB^, ioa_Request Do
  226.       Begin
  227.         io_Command := CMD_WRITE;
  228.         io_Flags := ADIOF_PERVOL;
  229.         ioa_Data := ^s^.Data;
  230.         ioa_Length := Laenge;
  231.         ioa_Volume := 64;
  232.         ioa_Period := Rate;
  233.         ioa_Cycles := 1;
  234.       End;
  235.     BeginIO(lockIOB);
  236. {$if def debug}
  237.     If not fromWB Then writeln('Playing...');
  238. {$endif}
  239.     err :=WaitIO(lockIOB)
  240.  End;
  241.  
  242. Function PlaySinit(Filename: String):Boolean; Export;
  243. Label  No_Play;
  244.  
  245. Begin
  246.  
  247.   Reset (F1, Filename);
  248.   If IOResult <> 0 Then begin
  249.     PlaySinit:=False;
  250.     Goto No_Play;
  251.   end;
  252.  
  253.   Buffer (F1, 5000);
  254.   MySample := LoadSample (F1);
  255.   Close (F1);
  256.   If MySample=Nil then PlaySinit:=False
  257.   Else  PlaySinit:=True;
  258.   InitAudio;
  259. No_Play:
  260. End;
  261.  
  262. Procedure EndPlay; Export;
  263. Begin
  264. {$if def debug}
  265.  Writeln('Schliesse Audio-Device');
  266. {$endif}
  267.  Close_Device(allocIOB);
  268. End;
  269.  
  270. Procedure Piep; Export;
  271. Begin
  272.  If MySample <> Nil Then
  273.       PlaySample(MySample);
  274. End;
  275.  
  276. Begin
  277.  { Tja, hier ist mir nichts eingefallen ... }
  278.  { Aber hier braucht auch nix zu stehen :-)  }
  279. End.
  280.  
  281. { Also ehrlich! Das Zeugs ist mächtig kompliziert... }
  282. { Wenn jemand noch KickPascal 1.0 haben sollte, das ist das Modul hier }
  283. { in das Hauptfile 'Getem.p' zu INCLUDE-n , da KP 1.0 noch keinen Linker hat..}
  284.  
  285.  
  286.  
  287.  
  288.